home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / indx18eu.zip / FILES.PAS < prev    next >
Pascal/Delphi Source File  |  1991-03-20  |  8KB  |  332 lines
  1. UNIT Files ;
  2.  
  3.                            INTERFACE
  4.  
  5. CONST
  6.        FILE_POSITION_OUT_OF_RANGE                = 1 ;
  7.  
  8. CONST
  9.        FILE_READ_ERROR                           = 2 ;
  10.  
  11. CONST
  12.        FILE_WRITE_ERROR                          = 3 ;
  13.  
  14.  
  15. VAR
  16.        fileError                                 : WORD ;
  17.  
  18.  
  19.  PROCEDURE   InsertRecord ( VAR f                : FILE ;
  20.                             VAR buffer                  ;
  21.                                 position         : LONGINT ;
  22.                                 lRecL            : WORD ) ;
  23.  
  24.  PROCEDURE   DeleteRecord ( VAR f                : FILE ;
  25.                                 position         : LONGINT ;
  26.                                 lRecL            : WORD ) ;
  27.  
  28.  
  29.  
  30.  
  31.  
  32.                        IMPLEMENTATION
  33.  
  34.  
  35.  PROCEDURE   InsertRecord ( VAR f                : FILE ;
  36.                             VAR buffer                  ;
  37.                                 position         : LONGINT ;
  38.                                 lRecL            : WORD ) ;
  39.  
  40. VAR
  41.        bytesToMove                               : LONGINT ;
  42.        fSize                                     : LONGINT ;
  43.        readPosition                              : LONGINT ;
  44.        writePosition                             : LONGINT ;
  45.        memBuf                                    : POINTER ;
  46.        memBufSize                                : WORD ;
  47.        toMove                                    : WORD ;
  48.        numRead                                   : WORD ;
  49.        numWritten                                : WORD ;
  50.        maxBufferRecords                          : WORD ;
  51.        lastLoop                                  : BOOLEAN ;
  52.        quitLoop                                  : BOOLEAN ;
  53.  
  54.    BEGIN  {  InsertRecord  }
  55.  
  56.      fSize                             := FileSize ( f ) ;
  57.  
  58.      IF ( position > ( fSize / lRecL ) )
  59.       THEN
  60.        BEGIN
  61.  
  62.          fileError := FILE_POSITION_OUT_OF_RANGE ;
  63.  
  64.          Exit ;
  65.  
  66.        END ;  {  IF  }
  67.  
  68.      bytesToMove := ( fSize - ( position * lRecL ) ) ;
  69.  
  70.      memBufSize := MaxAvail ;
  71.      maxBufferRecords := memBufSize DIV lRecL ;
  72.      memBufSize := maxBufferRecords * lRecL ;
  73.      GetMem ( memBuf , memBufSize ) ;
  74.  
  75.      IF ( bytesToMove <= memBufSize )
  76.       THEN
  77.        BEGIN
  78.  
  79.          Seek ( f , ( position * lRecL ) ) ;
  80.          BlockRead ( f , memBuf^ , bytesToMove , numRead ) ;
  81.          IF ( numRead < bytesToMove )
  82.           THEN
  83.            BEGIN
  84.  
  85.              fileError := FILE_READ_ERROR ;
  86.  
  87.              Exit ;
  88.  
  89.            END ;  {  IF  }
  90.  
  91.          Seek ( f , ( ( position + 1 ) * lRecL ) ) ;
  92.          BlockWrite ( f , memBuf^ , bytesToMove , numWritten ) ;
  93.  
  94.          IF ( numWritten < bytesToMove )
  95.           THEN
  96.            BEGIN
  97.  
  98.              fileError := FILE_WRITE_ERROR ;
  99.  
  100.              Exit ;
  101.  
  102.            END ;  {  IF  }
  103.  
  104.        END   {  THEN  }
  105.  
  106.       ELSE
  107.        BEGIN
  108.  
  109.          readPosition := ( fSize DIV lRecL ) - maxBufferRecords ;
  110.          writePosition := readPosition + 1 ;
  111.  
  112.          lastLoop := FALSE ;
  113.          quitLoop := FALSE ;
  114.          toMove   := memBufSize ;
  115.  
  116.          REPEAT
  117.  
  118.            IF ( lastLoop )
  119.             THEN
  120.                quitLoop := TRUE ;
  121.  
  122.            Seek ( f , readPosition * lRecL ) ;
  123.            BlockRead ( f , memBuf^ , toMove , numRead ) ;
  124.            IF ( numRead < toMove )
  125.             THEN
  126.              BEGIN
  127.  
  128.                fileError := FILE_READ_ERROR ;
  129.  
  130.                Exit ;
  131.  
  132.              END ;  {  IF  }
  133.  
  134.            Seek ( f , writePosition * lRecL ) ;
  135.            BlockWrite ( f , memBuf^ , toMove , numWritten ) ;
  136.            IF ( numWritten < toMove )
  137.             THEN
  138.              BEGIN
  139.  
  140.                fileError := FILE_WRITE_ERROR ;
  141.  
  142.                Exit ;
  143.  
  144.              END ;  {  IF  }
  145.  
  146.            readPosition := readPosition - maxBufferRecords ;
  147.  
  148.            IF ( readPosition <= position )
  149.             THEN
  150.              BEGIN
  151.  
  152.                toMove := ( writePosition - position - 1 ) * lRecL ;
  153.                readPosition := position ;
  154.                lastLoop := TRUE ;
  155.  
  156.              END ;  {  IF  }
  157.  
  158.            writePosition := readPosition + 1 ;
  159.  
  160.          UNTIL ( quitLoop ) ;
  161.  
  162.        END ;  {  ELSE  }
  163.  
  164.      FreeMem ( memBuf , memBufSize ) ;
  165.  
  166.      Seek ( f , ( position * lRecL ) ) ;
  167.      BlockWrite ( f , buffer , lRecL , numWritten ) ;
  168.  
  169.      IF ( numWritten < lRecL )
  170.       THEN
  171.        BEGIN
  172.  
  173.          fileError := FILE_WRITE_ERROR ;
  174.  
  175.          Exit ;
  176.  
  177.        END ;  {  IF  }
  178.  
  179.    END ;  {  InsertRecord  }
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  PROCEDURE   DeleteRecord ( VAR f                : FILE ;
  186.                                 position         : LONGINT ;
  187.                                 lRecL            : WORD ) ;
  188.  
  189. VAR
  190.        bytesToMove                               : LONGINT ;
  191.        fSize                                     : LONGINT ;
  192.        readPosition                              : LONGINT ;
  193.        writePosition                             : LONGINT ;
  194.        memBuf                                    : POINTER ;
  195.        memBufSize                                : WORD ;
  196.        toMove                                    : WORD ;
  197.        numRead                                   : WORD ;
  198.        numWritten                                : WORD ;
  199.        maxBufferRecords                          : WORD ;
  200.        lastLoop                                  : BOOLEAN ;
  201.        quitLoop                                  : BOOLEAN ;
  202.  
  203.    BEGIN  {  DeleteRecord  }
  204.  
  205.      fSize                             := FileSize ( f ) ;
  206.  
  207.      IF ( ( position + 1 ) > ( fSize / lRecL ) )
  208.       THEN
  209.        BEGIN
  210.  
  211.          fileError := FILE_POSITION_OUT_OF_RANGE ;
  212.  
  213.          Exit ;
  214.  
  215.        END ;  {  IF  }
  216.  
  217.      bytesToMove := ( fSize - ( ( position + 1 ) * lRecL ) ) ;
  218.  
  219.      memBufSize := MaxAvail ;
  220.      maxBufferRecords := memBufSize DIV lRecL ;
  221.      memBufSize := maxBufferRecords * lRecL ;
  222.      GetMem ( memBuf , memBufSize ) ;
  223.  
  224.      IF ( bytesToMove <= memBufSize )
  225.       THEN
  226.        BEGIN
  227.  
  228.          Seek ( f , ( ( position + 1 ) * lRecL ) ) ;
  229.          BlockRead ( f , memBuf^ , bytesToMove , numRead ) ;
  230.          IF ( numRead < bytesToMove )
  231.           THEN
  232.            BEGIN
  233.  
  234.              fileError := FILE_READ_ERROR ;
  235.  
  236.              Exit ;
  237.  
  238.            END ;  {  IF  }
  239.  
  240.          Seek ( f , ( position * lRecL ) ) ;
  241.          BlockWrite ( f , memBuf^ , bytesToMove , numWritten ) ;
  242.  
  243.          IF ( numWritten < bytesToMove )
  244.           THEN
  245.            BEGIN
  246.  
  247.              fileError := FILE_WRITE_ERROR ;
  248.  
  249.              Exit ;
  250.  
  251.            END ;  {  IF  }
  252.  
  253.           END   {  THEN  }
  254.  
  255.       ELSE
  256.        BEGIN
  257.  
  258.          readPosition := ( position + 1 ) ;
  259.          writePosition := position ;
  260.  
  261.          lastLoop := FALSE ;
  262.          quitLoop := FALSE ;
  263.          toMove   := memBufSize ;
  264.  
  265.          REPEAT
  266.  
  267.            IF ( lastLoop )
  268.             THEN
  269.                quitLoop := TRUE ;
  270.  
  271.            Seek ( f , readPosition * lRecL ) ;
  272.            BlockRead ( f , memBuf^ , toMove , numRead ) ;
  273.            IF ( numRead < toMove )
  274.             THEN
  275.              BEGIN
  276.  
  277.                fileError := FILE_READ_ERROR ;
  278.  
  279.                Exit ;
  280.  
  281.              END ;  {  IF  }
  282.  
  283.            Seek ( f , writePosition * lRecL ) ;
  284.            BlockWrite ( f , memBuf^ , toMove , numWritten ) ;
  285.            IF ( numWritten < toMove )
  286.             THEN
  287.              BEGIN
  288.  
  289.                fileError := FILE_WRITE_ERROR ;
  290.  
  291.                Exit ;
  292.  
  293.              END ;  {  IF  }
  294.  
  295.            readPosition := readPosition + maxBufferRecords ;
  296.  
  297.            IF ( readPosition >= ( fSize DIV lRecL ) )
  298.             THEN
  299.                quitLoop := TRUE ;
  300.  
  301.            IF ( readPosition + maxBufferRecords >= ( fSize DIV lRecL ) )
  302.             THEN
  303.              BEGIN
  304.  
  305.                toMove := fSize - ( readPosition * lRecL ) ;
  306.                lastLoop := TRUE ;
  307.  
  308.              END ;  {  IF  }
  309.  
  310.            writePosition := readPosition - 1 ;
  311.  
  312.          UNTIL ( quitLoop ) ;
  313.  
  314.        END ;  {  ELSE  }
  315.  
  316.      FreeMem ( memBuf , memBufSize ) ;
  317.  
  318.      Seek ( f , ( fSize - lRecL ) ) ;
  319.      Truncate ( f ) ;
  320.  
  321.    END ;  {  DeleteRecord  }
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  
  328. BEGIN
  329.  
  330.   fileError := 0 ;    {  no error yet  }
  331.  
  332. END .